home *** CD-ROM | disk | FTP | other *** search
/ Games of Daze / Infomagic - Games of Daze (Summer 1995) (Disc 1 of 2).iso / x2ftp / msdos / source / gfxfx / 3dl4a.pas < prev    next >
Pascal/Delphi Source File  |  1994-06-22  |  9KB  |  337 lines
  1.  
  2. {$g+,r-,q-,s+,t-,v+,x+}
  3. program polygoned_l4a;
  4. { Dedicated too... Guess who? }
  5. uses
  6.   crt;
  7. const
  8.   vidseg:word=$a000;
  9.   divd:word=128;
  10.   dist:word=200;
  11.   minx:word=0;
  12.   maxx:word=319;
  13.   border:boolean=false;
  14.   point:array[0..27,0..2] of integer=(
  15.     {l}
  16.     (-50,-25,  0),
  17.     (-20,-25,  0),
  18.     (-20,-15,  0),
  19.     (-40,-15,  0),
  20.     (-40, 25,  0),
  21.     (-50, 25,  0),
  22.     {4}
  23.     (-10,-25,  0),
  24.     (  0,-25,  0),
  25.     (  0, 25,  0),
  26.     (-10, 25,  0),
  27.     ( -8,  5,  0),
  28.     (-20,  5,  0),
  29.     (-20, 25,  0),
  30.     (-30, 25,  0),
  31.     (-30, -5,  0),
  32.     ( -8, -5,  0),
  33.     {a}
  34.     ( 10,-25,  0),
  35.     ( 20,-25,  0),
  36.     ( 18, -5,  0),
  37.     ( 32, -5,  0),
  38.     ( 30,-25,  0),
  39.     ( 40,-25,  0),
  40.     ( 40, 25,  0),
  41.     ( 10, 25,  0),
  42.     ( 18,  5,  0),
  43.     ( 32,  5,  0),
  44.     ( 30, 15,  0),
  45.     ( 20, 15,  0));
  46.  
  47.   planes:array[0..8,0..3] of byte=(
  48.     {l}
  49.     (0,1,2,3),
  50.     (0,3,4,5),
  51.     {4}
  52.     (6,7,8,9),
  53.     (14,15,10,11),
  54.     (14,11,12,13),
  55.     {a}
  56.     (16,17,27,23),
  57.     (27,26,22,23),
  58.     (20,21,22,26),
  59.     (18,19,25,24));
  60.  
  61. var
  62.   ctab,stab:array[0..255] of integer;
  63.   polyz:array[0..8] of integer;
  64.   pind:array[0..8] of byte;
  65.   address:word;
  66.  
  67. { -------------------------------------------------------------------------- }
  68.  
  69. function cosinus(i:byte):integer; begin cosinus:=ctab[i]; end;
  70. function sinus(i:byte):integer; begin sinus:=stab[i]; end;
  71.  
  72. { -------------------------------------------------------------------------- }
  73.  
  74. procedure setborder(col:byte); assembler; asm
  75.   xor ch,ch; mov cl,border; jcxz @out; mov dx,3dah; in al,dx
  76.   mov dx,3c0h; mov al,11h+32; out dx,al; mov al,col; out dx,al; @out: end;
  77.  
  78. procedure setpal(c,r,g,b:byte); assembler; asm
  79.   mov dx,3c8h; mov al,[c]; out dx,al; inc dx; mov al,[r]
  80.   out dx,al; mov al,[g]; out dx,al; mov al,[b]; out dx,al; end;
  81.  
  82. procedure retrace; assembler; asm
  83.   mov dx,3dah; @vert1: in al,dx; test al,8; jz @vert1
  84.   @vert2: in al,dx; test al,8; jnz @vert2; end;
  85.  
  86. procedure setmodex; assembler; asm
  87.   mov ax,13h; int 10h; mov dx,3c4h; mov ax,0604h; out dx,ax; mov ax,0f02h
  88.   out dx,ax; mov cx,320*200; mov es,vidseg; xor ax,ax; mov di,ax; rep stosw
  89.   mov dx,3d4h; mov ax,0014h; out dx,ax; mov ax,0e317h; out dx,ax; end;
  90.  
  91. procedure setaddress(ad:word); assembler; asm
  92.   mov dx,3d4h; mov al,0ch; mov ah,[byte(ad)+1]; out dx,ax
  93.   mov al,0dh; mov ah,[byte(ad)]; out dx,ax; end;
  94.  
  95. procedure cls; assembler; asm
  96.   mov es,vidseg; mov di,address; mov cx,8000; mov dx,3c4h
  97.   mov ax,0f02h; out dx,ax; xor ax,ax; rep stosw; end;
  98.  
  99. { -------------------------------------------------------------------------- }
  100.  
  101. procedure xhlin(x,x2,y:integer;c:byte); assembler;
  102. asm
  103.   mov ax,vidseg
  104.   mov es,ax
  105.   cld
  106.   mov ax,80
  107.   mul y
  108.   mov di,ax             { base of scan line }
  109.   add di,address
  110.   mov bx,[x]
  111.   mov dx,[x2]
  112.   cmp bx,dx
  113.   jb @skip
  114.   xchg bx,dx
  115.  @skip:
  116.   mov cl,bl
  117.   shr bx,2
  118.   mov ch,dl
  119.   shr dx,2
  120.   and cx,$0303
  121.   sub dx,bx             { width in Bytes }
  122.   add di,bx             { offset into video buffer }
  123.   mov ax,$ff02
  124.   shl ah,cl
  125.   and ah,$0f            { left edge mask }
  126.   mov cl,ch
  127.   mov bh,$f1
  128.   rol bh,cl
  129.   and bh,$0f            { right edge mask }
  130.   mov cx,dx
  131.   or cx,cx
  132.   jnz @left
  133.   and ah,bh             { combine left & right bitmasks }
  134.  @left:
  135.   mov dx,$03c4
  136.   out dx,ax
  137.   inc dx
  138.   mov al,[c]
  139.   stosb
  140.   jcxz @exit
  141.   dec cx
  142.   jcxz @right
  143.   mov al,$0f
  144.   out dx,al             { skipped if cx=0,1 }
  145.   mov al,[c]
  146.   repz stosb            { fill middle Bytes }
  147.  @right:
  148.   mov al,bh
  149.   out dx,al             { skipped if cx=0 }
  150.   mov al,[c]
  151.   stosb
  152.  @exit:
  153. end;
  154.  
  155. procedure polygon(x1,y1,x2,y2,x3,y3,x4,y4:integer; c:byte);
  156. var
  157.   xpos:array[0..199,0..1] of integer;
  158.   mul1,mul2,mul3,mul4,div1,div2,div3,div4,mny,mxy,y,tmp:integer;
  159.   i:word;
  160.   s1,s2,s3,s4:shortint;
  161.   dir1,dir2,dir3,dir4:byte;
  162. begin
  163.   mny:=y1;                             { determine highest and lowest point }
  164.   if y2<mny then mny:=y2;
  165.   if y3<mny then mny:=y3;
  166.   if y4<mny then mny:=y4;
  167.   mxy:=y1;
  168.   if y2>mxy then mxy:=y2;
  169.   if y3>mxy then mxy:=y3;
  170.   if y4>mxy then mxy:=y4;
  171.   if mny<0 then mny:=0;                { vertical range checking }
  172.   if mxy>199 then mxy:=199;
  173.   if mny>199 then exit;
  174.   if mxy<0 then exit;
  175.   dir1:=byte(y1<y2);
  176.   dir2:=byte(y2<y3);
  177.   dir3:=byte(y3<y4);
  178.   dir4:=byte(y4<y1);
  179.   s1:=dir1*2-1;                        { check directions (-1= down, 1=up) }
  180.   s2:=dir2*2-1;
  181.   s3:=dir3*2-1;
  182.   s4:=dir4*2-1;
  183.   mul1:=x2-x1; div1 := y2-y1;          { calculate constants }
  184.   mul2:=x3-x2; div2 := y3-y2;
  185.   mul3:=x4-x3; div3 := y4-y3;
  186.   mul4:=x1-x4; div4 := y1-y4;
  187.   y:=y1;
  188.   if y1<>y2 then repeat
  189.     if (y>=mny) and (y<=mxy) then begin
  190.       tmp:=mul1*(y-y1) div div1+x1;
  191.       if tmp<minx then xpos[y,dir1]:=minx    { horizontal range checking }
  192.       else if tmp>maxx then xpos[y,dir1]:=maxx
  193.       else xpos[y,dir1]:=tmp;
  194.     end;
  195.     inc(y,s1);
  196.   until y=y2+s1
  197.   else if (y>=mny) and (y<=mxy) then begin
  198.     tmp:=x1;
  199.     if tmp<minx then xpos[y,dir1]:=minx
  200.     else if tmp>maxx then xpos[y,dir1]:=maxx
  201.     else xpos[y,dir1]:=tmp;
  202.   end;
  203.   y:=y2;
  204.   if y2<>y3 then repeat
  205.     if (y>=mny) and (y<=mxy) then begin
  206.       tmp:=mul2*(y-y2) div div2+x2;
  207.       if tmp<minx then xpos[y,dir2]:=minx
  208.       else if tmp>maxx then xpos[y,dir2]:=maxx
  209.       else xpos[y,dir2]:=tmp;
  210.     end;
  211.     inc(y,s2);
  212.   until y=y3+s2
  213.   else if (y>=mny) and (y<=mxy) then begin
  214.     tmp:=x2;
  215.     if tmp<minx then xpos[y,dir2]:=minx
  216.     else if tmp>maxx then xpos[y,dir2]:=maxx
  217.     else xpos[y,dir2]:=tmp;
  218.   end;
  219.   y:=y3;
  220.   if y3<>y4 then repeat
  221.     if (y>=mny) and (y<=mxy) then begin
  222.       tmp:=mul3*(y-y3) div div3+x3;
  223.       if tmp<minx then xpos[y,dir3]:=minx
  224.       else if tmp>maxx then xpos[y,dir3]:=maxx
  225.       else xpos[y,dir3]:=tmp;
  226.     end;
  227.     inc(y,s3);
  228.   until y=y4+s3
  229.   else if (y>=mny) and (y<=mxy) then begin
  230.     tmp:=x3;
  231.     if tmp<minx then xpos[y,dir3]:=minx
  232.     else if tmp>maxx then xpos[y,dir3]:=maxx
  233.     else xpos[y,dir3]:=tmp;
  234.   end;
  235.   y:=y4;
  236.   if y4<>y1 then repeat
  237.     if (y>=mny) and (y<=mxy) then begin
  238.       tmp:=mul4*(y-y4) div div4+x4;
  239.       if tmp<minx then xpos[y,dir4]:=minx
  240.       else if tmp>maxx then xpos[y,dir4]:=maxx
  241.       else xpos[y,dir4]:=tmp;
  242.     end;
  243.     inc(y,s4);
  244.   until y=y1+s4
  245.   else if (y>=mny) and (y<=mxy) then begin
  246.     tmp:=x4;
  247.     if tmp<minx then xpos[y,dir4]:=minx
  248.     else if tmp>maxx then xpos[y,dir4]:=maxx
  249.     else xpos[y,dir4]:=tmp;
  250.   end;
  251.   for y:=mny to mxy do
  252.     xhlin(xpos[y,0],xpos[y,1],y,c);
  253. end;
  254.  
  255. { -------------------------------------------------------------------------- }
  256.  
  257. procedure quicksort(lo,hi:integer);
  258.  
  259. procedure sort(l,r:integer);
  260. var i,j,x,y:integer;
  261. begin
  262.   i:=l; j:=r; x:=polyz[(l+r) div 2];
  263.   repeat
  264.     while polyz[i]<x do inc(i);
  265.     while x<polyz[j] do dec(j);
  266.     if i<=j then begin
  267.       y:=polyz[i]; polyz[i]:=polyz[j]; polyz[j]:=y;
  268.       y:=pind[i]; pind[i]:=pind[j]; pind[j]:=y;
  269.       inc(i); dec(j);
  270.     end;
  271.   until i>j;
  272.   if l<j then sort(l,j);
  273.   if i<r then sort(i,r);
  274. end;
  275.  
  276. begin
  277.   sort(lo,hi);
  278. end;
  279.  
  280. { -------------------------------------------------------------------------- }
  281.  
  282. procedure rotate;
  283. const
  284.   xst=-1; yst=-2; zst=2;
  285. var
  286.   xp,yp,z:array[0..27] of integer;
  287.   x,y,i,j,k:integer;
  288.   n,Key,phix,phiy,phiz:byte;
  289. begin
  290.   address := 0;
  291.   phix:=30; phiy:=0; phiz:=0;
  292.   fillchar(xp,sizeof(xp),0);
  293.   fillchar(yp,sizeof(yp),0);
  294.   fillchar(z,sizeof(z),0);
  295.   repeat
  296.     retrace;
  297.     setborder(1);
  298.     for n:=0 to 27 do begin
  299.       i:=(cosinus(phiy)*point[n,0]-sinus(phiy)*point[n,2]) div divd;
  300.       j:=(cosinus(phiz)*point[n,1]-sinus(phiz)*i) div divd;
  301.       k:=(cosinus(phiy)*point[n,2]+sinus(phiy)*point[n,0]) div divd;
  302.       x:=(cosinus(phiz)*i+sinus(phiz)*point[n,1]) div divd+cosinus(phix) div 2;
  303.       y:=(cosinus(phix)*j+sinus(phix)*k) div divd+sinus(phix) div 3;
  304.       z[n]:=(cosinus(phix)*k-sinus(phix)*j) div divd;
  305.       xp[n]:=160+(-x*dist) div (z[n]-dist);
  306.       yp[n]:=100+(-y*dist) div (z[n]-dist);
  307.     end;
  308.     for n:=0 to 8 do begin
  309.       polyz[n]:=(z[planes[n,0]]+z[planes[n,1]]+z[planes[n,2]]+z[planes[n,3]]) div 4;
  310.       pind[n]:=n;
  311.     end;
  312.     quicksort(0,8);
  313.     address:=16000-address;
  314.     setaddress(address);
  315.     cls;
  316.     for n:=0 to 8 do
  317.       polygon(xp[planes[pind[n],0]],yp[planes[pind[n],0]],
  318.               xp[planes[pind[n],1]],yp[planes[pind[n],1]],
  319.               xp[planes[pind[n],2]],yp[planes[pind[n],2]],
  320.               xp[planes[pind[n],3]],yp[planes[pind[n],3]],1);
  321.     inc(phix,xst); inc(phiy,yst); inc(phiz,zst);
  322.     setborder(0);
  323.   until keypressed;
  324. end;
  325.  
  326. { -------------------------------------------------------------------------- }
  327.  
  328. var i,j:byte;
  329. begin
  330.   setmodex;
  331.   setpal(1,25,20,60);
  332.   for i:=0 to 255 do ctab[i]:=round(-cos(i*pi/128)*divd);
  333.   for i:=0 to 255 do stab[i]:=round(sin(i*pi/128)*divd);
  334.   rotate;
  335.   textmode(lastmode);
  336. end.
  337.